home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / PowerMacOberon feb96 / Source / POPB.Mod (.txt) < prev    next >
Encoding:
Oberon Text  |  1995-06-12  |  51.5 KB  |  1,466 lines  |  [TEXT/.Ob4]
  1. Syntax10b.Scn.Fnt
  2. Syntax10.Scn.Fnt
  3. Syntax10i.Scn.Fnt
  4. InfoElems
  5. Alloc
  6. Syntax10.Scn.Fnt
  7. Syntax10i.Scn.Fnt
  8. StampElems
  9. Alloc
  10. 12 Jun 95
  11. "Title": no title
  12. "Author": RC 
  13. "Abstract": no abstract
  14. "Keywords": no keywords
  15. "Version": no version
  16. "From":   6.3.89 / 16.2.94
  17. "Until": 
  18. "Changes": 
  19. 12. 6. 95 introducing err(85) to prevent down guard
  20. MODULE POPB;    (* RC 6.3.89 / 16.2.94 *)
  21. (* build parse tree *) 
  22.     IMPORT OPT := POPT, OPS := POPS, OPM := POPM;
  23.     CONST
  24.         (* symbol values or ops *)
  25.         times = 1; slash = 2; div = 3; mod = 4;
  26.         and = 5; plus = 6; minus = 7; or = 8; eql = 9;
  27.         neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
  28.         in = 15; is = 16; ash = 17; msk = 18; len = 19;
  29.         conv = 20; abs = 21; cap = 22; odd = 23; not = 33;
  30.         (*SYSTEM*)
  31.         adr = 24; cc = 25; bit = 26; lsh = 27; rot = 28; val = 29;
  32.         (* object modes *)
  33.         Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
  34.         SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
  35.         (* Structure forms *)
  36.         Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
  37.         Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
  38.         Pointer = 13; ProcTyp = 14; Comp = 15;
  39.         intSet = {SInt..LInt}; realSet = {Real, LReal};
  40.         (* composite structure forms *)
  41.         Basic = 1; Array = 2; DynArr = 3; Record = 4;
  42.         (* nodes classes *)
  43.         Nvar = 0; Nvarpar = 1; Nfield = 2; Nderef = 3; Nindex = 4; Nguard = 5; Neguard = 6;
  44.         Nconst = 7; Ntype = 8; Nproc = 9; Nupto = 10; Nmop = 11; Ndop = 12; Ncall = 13;
  45.         Ninittd = 14; Nif = 15; Ncaselse = 16; Ncasedo = 17; Nenter = 18; Nassign = 19;
  46.         Nifelse = 20; Ncase = 21; Nwhile = 22; Nrepeat = 23; Nloop = 24; Nexit = 25;
  47.         Nreturn = 26; Nwith = 27; Ntrap = 28;
  48.         (*function number*)
  49.         assign = 0;
  50.         haltfn = 0; newfn = 1; absfn = 2; capfn = 3; ordfn = 4;
  51.         entierfn = 5; oddfn = 6; minfn = 7; maxfn = 8; chrfn = 9;
  52.         shortfn = 10; longfn = 11; sizefn = 12; incfn = 13; decfn = 14;
  53.         inclfn = 15; exclfn = 16; lenfn = 17; copyfn = 18; ashfn = 19; assertfn = 32;
  54.         (*SYSTEM function number*)
  55.         adrfn = 20; ccfn = 21; lshfn = 22; rotfn = 23;
  56.         getfn = 24; putfn = 25; getrfn = 26; putrfn = 27;
  57.         bitfn = 28; valfn = 29; sysnewfn = 30; movefn = 31;
  58.         (* module visibility of objects *)
  59.         internal = 0; external = 1; externalR = 2;
  60.         (* procedure flags (conval^.setval) *)
  61.         hasBody = 1; isRedef = 2; slNeeded = 3;
  62.         AssertTrap = 0;    (* default trap number *)
  63.         typSize*: PROCEDURE(typ: OPT.Struct; allocDesc: BOOLEAN);
  64.         exp: INTEGER;    (*side effect of log*)
  65.         maxExp: LONGINT;    (* max n in ASH(1, n) on this machine *)
  66.     PROCEDURE err(n: INTEGER);
  67.     BEGIN OPM.err(n)
  68.     END err;
  69.     PROCEDURE NewLeaf*(obj: OPT.Object): OPT.Node;
  70.         VAR node: OPT.Node;
  71.     BEGIN
  72.         CASE obj^.mode OF
  73.           Var:
  74.                 node := OPT.NewNode(Nvar); node^.readonly := (obj^.vis = externalR) & (obj^.mnolev < 0)
  75.         | VarPar:
  76.                 node := OPT.NewNode(Nvarpar)
  77.         | Con:
  78.                 node := OPT.NewNode(Nconst); node^.conval := OPT.NewConst();
  79.                 node^.conval^ := obj^.conval^    (* string is not copied, only its ref *)
  80.         | Typ:
  81.                 node := OPT.NewNode(Ntype)
  82.         | LProc..IProc:
  83.                 node := OPT.NewNode(Nproc)
  84.         ELSE err(127); node := OPT.NewNode(Nvar)
  85.         END ;
  86.         node^.obj := obj; node^.typ := obj^.typ;
  87.         RETURN node
  88.     END NewLeaf;
  89.     PROCEDURE Construct*(class: SHORTINT; VAR x: OPT.Node;  y: OPT.Node);
  90.         VAR node: OPT.Node;
  91.     BEGIN
  92.         node := OPT.NewNode(class); node^.typ := OPT.notyp;
  93.         node^.left := x; node^.right := y; x := node
  94.     END Construct;
  95.     PROCEDURE Link*(VAR x, last: OPT.Node; y: OPT.Node);
  96.     BEGIN
  97.         IF x = NIL THEN x := y ELSE last^.link := y END ;
  98.         WHILE y^.link # NIL DO y := y^.link END ;
  99.         last := y
  100.     END Link;
  101.     PROCEDURE BoolToInt(b: BOOLEAN): LONGINT;
  102.     BEGIN
  103.         IF b THEN RETURN 1 ELSE RETURN 0 END
  104.     END BoolToInt;
  105.     PROCEDURE IntToBool(i: LONGINT): BOOLEAN;
  106.     BEGIN
  107.         IF i = 0 THEN RETURN FALSE ELSE RETURN TRUE END
  108.     END IntToBool;
  109.     PROCEDURE NewBoolConst*(boolval: BOOLEAN): OPT.Node;
  110.         VAR x: OPT.Node;
  111.     BEGIN
  112.         x := OPT.NewNode(Nconst); x^.typ := OPT.booltyp;
  113.         x^.conval := OPT.NewConst(); x^.conval^.intval := BoolToInt(boolval); RETURN x
  114.     END NewBoolConst;
  115.     PROCEDURE OptIf*(VAR x: OPT.Node);    (* x^.link = NIL *)
  116.         VAR if, pred: OPT.Node;
  117.     BEGIN
  118.         if := x^.left;
  119.         WHILE if^.left^.class = Nconst DO
  120.             IF IntToBool(if^.left^.conval^.intval) THEN x := if^.right; RETURN
  121.             ELSIF if^.link = NIL THEN x := x^.right; RETURN
  122.             ELSE if := if^.link; x^.left := if
  123.             END
  124.         END ;
  125.         pred := if; if := if^.link;
  126.         WHILE if # NIL DO
  127.             IF if^.left^.class = Nconst THEN
  128.                 IF IntToBool(if^.left^.conval^.intval) THEN
  129.                     pred^.link := NIL; x^.right := if^.right; RETURN
  130.                 ELSE if := if^.link; pred^.link := if
  131.                 END
  132.             ELSE pred := if; if := if^.link
  133.             END
  134.         END
  135.     END OptIf;
  136.     PROCEDURE Nil*(): OPT.Node;
  137.         VAR x: OPT.Node;
  138.     BEGIN
  139.         x := OPT.NewNode(Nconst); x^.typ := OPT.niltyp;
  140.         x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.nilval; RETURN x
  141.     END Nil;
  142.     PROCEDURE EmptySet*(): OPT.Node;
  143.         VAR x: OPT.Node;
  144.     BEGIN
  145.         x := OPT.NewNode(Nconst); x^.typ := OPT.settyp;
  146.         x^.conval := OPT.NewConst(); x^.conval^.setval := {}; RETURN x
  147.     END EmptySet;
  148.     PROCEDURE SetIntType(node: OPT.Node);
  149.         VAR v: LONGINT;
  150.     BEGIN v := node^.conval^.intval;
  151.         IF (OPM.MinSInt <= v) & (v <= OPM.MaxSInt) THEN node^.typ := OPT.sinttyp
  152.         ELSIF (OPM.MinInt <= v) & (v <= OPM.MaxInt) THEN node^.typ := OPT.inttyp
  153.         ELSIF (OPM.MinLInt <= v) & (v <= OPM.MaxLInt) (*bootstrap or cross*) THEN
  154.             node^.typ := OPT.linttyp
  155.         ELSE err(203); node^.typ := OPT.sinttyp; node^.conval^.intval := 1
  156.         END
  157.     END SetIntType;
  158.     PROCEDURE NewIntConst*(intval: LONGINT): OPT.Node;
  159.         VAR x: OPT.Node;
  160.     BEGIN
  161.         x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst();
  162.         x^.conval^.intval := intval; SetIntType(x); RETURN x
  163.     END NewIntConst;
  164.     PROCEDURE NewRealConst*(realval: LONGREAL; typ: OPT.Struct): OPT.Node;
  165.         VAR x: OPT.Node;
  166.     BEGIN
  167.         x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst();
  168.         x^.conval^.realval := realval; x^.typ := typ; x^.conval^.intval := OPM.ConstNotAlloc;
  169.         RETURN x
  170.     END NewRealConst;
  171.     PROCEDURE NewString*(VAR str: OPS.String; len: LONGINT): OPT.Node;
  172.         VAR x: OPT.Node;
  173.     BEGIN
  174.         x := OPT.NewNode(Nconst); x^.conval := OPT.NewConst(); x^.typ := OPT.stringtyp;
  175.         x^.conval^.intval := OPM.ConstNotAlloc; x^.conval^.intval2 := len;
  176.         x^.conval^.ext := OPT.NewExt(); x^.conval^.ext^ := str;
  177.         RETURN x
  178.     END NewString;
  179.     PROCEDURE CharToString(n: OPT.Node);
  180.         VAR ch: CHAR;
  181.     BEGIN
  182.         n^.typ := OPT.stringtyp; ch := CHR(n^.conval^.intval); n^.conval^.ext := OPT.NewExt();
  183.         IF ch = 0X THEN n^.conval^.intval2 := 1 ELSE n^.conval^.intval2 := 2; n^.conval^.ext[1] := 0X END ;
  184.         n^.conval^.ext[0] := ch; n^.conval^.intval := OPM.ConstNotAlloc; n^.obj := NIL
  185.     END CharToString;
  186.     PROCEDURE BindNodes(class: SHORTINT; typ: OPT.Struct; VAR x: OPT.Node; y: OPT.Node);
  187.         VAR node: OPT.Node;
  188.     BEGIN
  189.         node := OPT.NewNode(class); node^.typ := typ;
  190.         node^.left := x; node^.right := y; x := node
  191.     END BindNodes;
  192.     PROCEDURE NotVar(x: OPT.Node): BOOLEAN;
  193.     BEGIN RETURN (x^.class >= Nconst) & ((x^.class # Nmop) OR (x^.subcl # val) OR (x^.left^.class >= Nconst))
  194.     END NotVar;
  195.     PROCEDURE DeRef*(VAR x: OPT.Node);
  196.     BEGIN
  197.         IF x^.class >= Nconst THEN err(78)
  198.         ELSIF x^.typ^.form = Pointer THEN BindNodes(Nderef, x^.typ^.BaseTyp, x, NIL)
  199.         ELSE err(84)
  200.         END
  201.     END DeRef;
  202.     PROCEDURE Index*(VAR x: OPT.Node; y: OPT.Node);
  203.         VAR f: INTEGER; typ: OPT.Struct;
  204.     BEGIN
  205.         f := y^.typ^.form;
  206.         IF x^.class >= Nconst THEN err(79)
  207.         ELSIF ~(f IN intSet) THEN err(80); y^.typ := OPT.inttyp END ;
  208.         IF x^.typ^.comp = Array THEN typ := x^.typ^.BaseTyp;
  209.             IF (y^.class = Nconst) & ((y^.conval^.intval < 0) OR (y^.conval^.intval >= x^.typ^.n)) THEN err(81) END
  210.         ELSIF x^.typ^.comp = DynArr THEN typ := x^.typ^.BaseTyp;
  211.             IF (y^.class = Nconst) & (y^.conval^.intval < 0) THEN err(81) END
  212.         ELSE err(82); typ := OPT.undftyp
  213.         END ;
  214.         BindNodes(Nindex, typ, x, y); x^.readonly := x^.left^.readonly
  215.     END Index;
  216.     PROCEDURE Field*(VAR x: OPT.Node; y: OPT.Object);
  217.     BEGIN (*x^.typ^.comp = Record*)
  218.         IF x^.class >= Nconst THEN err(77) END ;
  219.         IF (y # NIL) & (y^.mode IN {Fld, TProc}) THEN
  220.             BindNodes(Nfield, y^.typ, x, NIL); x^.obj := y;
  221.             x^.readonly := x^.left^.readonly OR ((y^.vis = externalR) & (y^.mnolev < 0))
  222.         ELSE err(83); x^.typ := OPT.undftyp
  223.         END
  224.     END Field;
  225.     PROCEDURE TypTest*(VAR x: OPT.Node; obj: OPT.Object; guard: BOOLEAN);
  226.         PROCEDURE GTT(t0, t1: OPT.Struct);
  227.             VAR node: OPT.Node; t: OPT.Struct;
  228.         BEGIN t := t0;
  229.             WHILE (t # NIL) & (t # t1) & (t # OPT.undftyp) DO t := t^.BaseTyp END ;
  230.             IF t # t1 THEN
  231.                 WHILE (t1 # NIL) & (t1 # t0) & (t1 # OPT.undftyp) DO t1 := t1^.BaseTyp END ;
  232.                 IF t1 = t0 THEN
  233.                     IF guard THEN BindNodes(Nguard, NIL, x, NIL); x^.readonly := x^.left^.readonly
  234.                     ELSE node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x;
  235.                         node^.obj := obj; x := node
  236.                     END
  237.                 ELSE err(85)
  238.                 END
  239.               ELSIF t0 # t1 THEN err(85)      (* prevent down guard *)
  240.             ELSIF ~guard THEN
  241.                 IF x^.class = Nguard THEN    (* cannot skip guard *)
  242.                     node := OPT.NewNode(Nmop); node^.subcl := is; node^.left := x;
  243.                     node^.obj := obj; x := node
  244.                 ELSE x := NewBoolConst(TRUE)
  245.                 END
  246.             END
  247.         END GTT;
  248.     BEGIN
  249.         IF NotVar(x) THEN err(112)
  250.         ELSIF x^.typ^.form = Pointer THEN
  251.             IF x^.typ^.BaseTyp^.comp # Record THEN err(85)
  252.             ELSIF obj^.typ^.form = Pointer THEN GTT(x^.typ^.BaseTyp, obj^.typ^.BaseTyp)
  253.             ELSE err(86)
  254.             END
  255.         ELSIF (x^.typ^.comp = Record) & (x^.class = Nvarpar) & (obj^.typ^.comp = Record) THEN
  256.             GTT(x^.typ, obj^.typ)
  257.         ELSE err(87)
  258.         END ;
  259.         IF guard THEN x^.typ := obj^.typ ELSE x^.typ := OPT.booltyp END
  260.     END TypTest;
  261.     PROCEDURE In*(VAR x: OPT.Node; y: OPT.Node);
  262.         VAR f: INTEGER; k: LONGINT;
  263.     BEGIN f := x^.typ^.form;
  264.         IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126)
  265.         ELSIF (f IN intSet) & (y^.typ^.form = Set) THEN
  266.             IF x^.class = Nconst THEN
  267.                 k := x^.conval^.intval;
  268.                 IF (k < 0) OR (k > OPM.MaxSet) THEN err(202)
  269.                 ELSIF y^.class = Nconst THEN x^.conval^.intval := BoolToInt(k IN y^.conval^.setval); x^.obj := NIL
  270.                 ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in
  271.                 END
  272.             ELSE BindNodes(Ndop, OPT.booltyp, x, y); x^.subcl := in
  273.             END
  274.         ELSE err(92)
  275.         END ;
  276.         x^.typ := OPT.booltyp
  277.     END In;
  278.     PROCEDURE log(x: LONGINT): LONGINT;
  279.     BEGIN exp := 0;
  280.         IF x > 0 THEN
  281.             WHILE ~ODD(x) DO x := x DIV 2; INC(exp) END
  282.         END ;
  283.         RETURN x
  284.     END log;
  285.     PROCEDURE CheckRealType(f, nr: INTEGER; x: OPT.Const);
  286.         VAR min, max, r: LONGREAL;
  287.     BEGIN
  288.         IF f = Real THEN min := OPM.MinReal; max := OPM.MaxReal
  289.         ELSE min := OPM.MinLReal; max := OPM.MaxLReal
  290.         END ;
  291.         r := ABS(x^.realval);
  292.         IF (r > max) OR (r < min) THEN
  293.                 err(nr); x^.realval := 1.0
  294.         ELSIF f = Real THEN x^.realval := SHORT(x^.realval)    (* single precision only *)
  295.         END ;
  296.         x^.intval := OPM.ConstNotAlloc
  297.     END CheckRealType;
  298.     PROCEDURE MOp*(op: SHORTINT; VAR x: OPT.Node);
  299.         VAR f: INTEGER; typ: OPT.Struct; z: OPT.Node;
  300.         PROCEDURE NewOp(op: SHORTINT; typ: OPT.Struct; z: OPT.Node): OPT.Node;
  301.             VAR node: OPT.Node;
  302.         BEGIN
  303.             node := OPT.NewNode(Nmop); node^.subcl := op; node^.typ := typ;
  304.             node^.left := z; RETURN node
  305.         END NewOp;
  306.     BEGIN z := x;
  307.         IF (z^.class = Ntype) OR (z^.class = Nproc) THEN err(126)
  308.         ELSE typ := z^.typ; f := typ^.form;
  309.             CASE op OF
  310.               not:
  311.                     IF f = Bool THEN
  312.                         IF z^.class = Nconst THEN
  313.                             z^.conval^.intval := BoolToInt(~IntToBool(z^.conval^.intval)); z^.obj := NIL
  314.                         ELSE z := NewOp(op, typ, z)
  315.                         END
  316.                     ELSE err(98)
  317.                     END
  318.             | plus:
  319.                     IF ~(f IN intSet + realSet) THEN err(96) END
  320.             | minus:
  321.                     IF f IN intSet + realSet +{Set}THEN
  322.                         IF z^.class = Nconst THEN
  323.                             IF f IN intSet THEN
  324.                                 IF z^.conval^.intval = MIN(LONGINT) THEN err(203)
  325.                                 ELSE z^.conval^.intval := -z^.conval^.intval; SetIntType(z)
  326.                                 END
  327.                             ELSIF f IN realSet THEN z^.conval^.realval := -z^.conval^.realval
  328.                             ELSE z^.conval^.setval := -z^.conval^.setval
  329.                             END ;
  330.                             z^.obj := NIL
  331.                         ELSE z := NewOp(op, typ, z)
  332.                         END
  333.                     ELSE err(97)
  334.                     END
  335.             | abs:
  336.                     IF f IN intSet + realSet THEN
  337.                         IF z^.class = Nconst THEN
  338.                             IF f IN intSet THEN
  339.                                 IF z^.conval^.intval = MIN(LONGINT) THEN err(203)
  340.                                 ELSE z^.conval^.intval := ABS(z^.conval^.intval); SetIntType(z)
  341.                                 END
  342.                             ELSE z^.conval^.realval := ABS(z^.conval^.realval)
  343.                             END ;
  344.                             z^.obj := NIL
  345.                         ELSE z := NewOp(op, typ, z)
  346.                         END
  347.                     ELSE err(111)
  348.                     END
  349.             | cap:
  350.                     IF f = Char THEN
  351.                         IF z^.class = Nconst THEN
  352.                             z^.conval^.intval := ORD(CAP(CHR(z^.conval^.intval))); z^.obj := NIL
  353.                         ELSE z := NewOp(op, typ, z)
  354.                         END
  355.                     ELSE err(111); z^.typ := OPT.chartyp
  356.                     END
  357.             | odd:
  358.                     IF f IN intSet THEN
  359.                         IF z^.class = Nconst THEN
  360.                             z^.conval^.intval := BoolToInt(ODD(z^.conval^.intval)); z^.obj := NIL
  361.                         ELSE z := NewOp(op, typ, z)
  362.                         END
  363.                     ELSE err(111)
  364.                     END ;
  365.                     z^.typ := OPT.booltyp
  366.             | adr: (*SYSTEM.ADR*)
  367.                     IF (z^.class < Nconst) OR (f = String) THEN z := NewOp(op, typ, z)
  368.                     ELSE err(127)
  369.                     END ;
  370.                     z^.typ := OPT.linttyp
  371.             | cc: (*SYSTEM.CC*)
  372.                     IF (f IN intSet) & (z^.class = Nconst) THEN
  373.                         IF (0 <= z^.conval^.intval) & (z^.conval^.intval <= OPM.MaxCC) THEN z := NewOp(op, typ, z) ELSE err(219) END
  374.                     ELSE err(69)
  375.                     END ;
  376.                     z^.typ := OPT.booltyp
  377.             END
  378.         END ;
  379.         x := z
  380.     END MOp;
  381.     PROCEDURE CheckPtr(x, y: OPT.Node);
  382.         VAR g: INTEGER; p, q, t: OPT.Struct;
  383.     BEGIN g := y^.typ^.form;
  384.         IF g = Pointer THEN
  385.             p := x^.typ^.BaseTyp; q := y^.typ^.BaseTyp;
  386.             IF (p^.comp = Record) & (q^.comp = Record) THEN
  387.                 IF p^.extlev < q^.extlev THEN t := p; p := q; q := t END ;
  388.                 WHILE (p # q) & (p # NIL) & (p # OPT.undftyp) DO p := p^.BaseTyp END ;
  389.                 IF p = NIL THEN err(100) END
  390.             ELSE err(100)
  391.             END
  392.         ELSIF g # NilTyp THEN err(100)
  393.         END
  394.     END CheckPtr;
  395.     PROCEDURE CheckParameters*(fp, ap: OPT.Object; checkNames: BOOLEAN);
  396.         VAR ft, at: OPT.Struct;
  397.     BEGIN
  398.         WHILE fp # NIL DO
  399.             IF ap # NIL THEN
  400.                 ft := fp^.typ; at := ap^.typ;
  401.                 WHILE (ft^.comp = DynArr) & (at^.comp = DynArr) DO
  402.                     ft := ft^.BaseTyp; at := at^.BaseTyp
  403.                 END ;
  404.                 IF ft # at THEN
  405.                     IF (ft^.form = ProcTyp) & (at^.form = ProcTyp) THEN
  406.                         IF ft^.BaseTyp = at^.BaseTyp THEN CheckParameters(ft^.link, at^.link, FALSE)
  407.                         ELSE err(117)
  408.                         END
  409.                     ELSE err(115)
  410.                     END
  411.                 END ;
  412.                 IF (fp^.mode # ap^.mode) OR checkNames & (fp^.name # ap^.name) THEN err(115) END ;
  413.                 ap := ap^.link
  414.             ELSE err(116)
  415.             END ;
  416.             fp := fp^.link
  417.         END ;
  418.         IF ap # NIL THEN err(116) END
  419.     END CheckParameters;
  420.     PROCEDURE CheckProc(x: OPT.Struct; y: OPT.Object);    (* proc var x := proc y, check compatibility *)
  421.     BEGIN
  422.         IF y^.mode IN {XProc, IProc, LProc} THEN
  423.             IF y^.mode = LProc THEN
  424.                 IF y^.mnolev = 0 THEN y^.mode := XProc
  425.                 ELSE err(73)
  426.                 END
  427.             END ;
  428.             IF x^.BaseTyp = y^.typ THEN CheckParameters(x^.link, y^.link, FALSE)
  429.             ELSE err(117)
  430.             END
  431.         ELSE err(113)
  432.         END
  433.     END CheckProc;
  434.     PROCEDURE ConstOp(op: INTEGER; x, y: OPT.Node);
  435.         VAR f, g: INTEGER; xval, yval: OPT.Const; xv, yv: LONGINT;
  436.                 temp: BOOLEAN; (* temp avoids err 215 *)
  437.         PROCEDURE ConstCmp(): INTEGER;
  438.             VAR res: INTEGER;
  439.         BEGIN
  440.             CASE f OF
  441.               Undef:
  442.                     res := eql
  443.             | Byte, Char..LInt:
  444.                     IF xval^.intval < yval^.intval THEN res := lss
  445.                     ELSIF xval^.intval > yval^.intval THEN res := gtr
  446.                     ELSE res := eql
  447.                     END
  448.             | Real, LReal:
  449.                     IF xval^.realval < yval^.realval THEN res := lss
  450.                     ELSIF xval^.realval > yval^.realval THEN res := gtr
  451.                     ELSE res := eql
  452.                     END
  453.             | Bool:
  454.                     IF xval^.intval # yval^.intval THEN res := neq
  455.                     ELSE res := eql
  456.                     END
  457.             | Set:
  458.                     IF xval^.setval # yval^.setval THEN res := neq
  459.                     ELSE res := eql
  460.                     END
  461.             | String:
  462.                     IF xval^.ext^ < yval^.ext^ THEN res := lss
  463.                     ELSIF xval^.ext^ > yval^.ext^ THEN res := gtr
  464.                     ELSE res := eql
  465.                     END
  466.             | NilTyp, Pointer, ProcTyp:
  467.                     IF xval^.intval # yval^.intval THEN res := neq
  468.                     ELSE res := eql
  469.                     END
  470.             END ;
  471.             x^.typ := OPT.booltyp; RETURN res
  472.         END ConstCmp;
  473.     BEGIN
  474.         f := x^.typ^.form; g := y^.typ^.form; xval := x^.conval; yval := y^.conval;
  475.         IF f # g THEN
  476.             CASE f OF
  477.               Char:
  478.                     IF g = String THEN CharToString(x)
  479.                     ELSE err(100); y^.typ := x^.typ; yval^ := xval^
  480.                     END ;
  481.             | SInt:
  482.                     IF g IN intSet THEN x^.typ := y^.typ
  483.                     ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval
  484.                     ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval
  485.                     ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  486.                     END
  487.             | Int:
  488.                     IF g = SInt THEN y^.typ := OPT.inttyp
  489.                     ELSIF g IN intSet THEN x^.typ := y^.typ
  490.                     ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval
  491.                     ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval
  492.                     ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  493.                     END
  494.             | LInt:
  495.                     IF g IN intSet THEN y^.typ := OPT.linttyp
  496.                     ELSIF g = Real THEN x^.typ := OPT.realtyp; xval^.realval := xval^.intval
  497.                     ELSIF g = LReal THEN x^.typ := OPT.lrltyp; xval^.realval := xval^.intval
  498.                     ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  499.                     END
  500.             | Real:
  501.                     IF g IN intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval
  502.                     ELSIF g = LReal THEN x^.typ := OPT.lrltyp
  503.                     ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  504.                     END
  505.             | LReal:
  506.                     IF g IN intSet THEN y^.typ := x^.typ; yval^.realval := yval^.intval
  507.                     ELSIF g = Real THEN y^.typ := OPT.lrltyp
  508.                     ELSE  err(100); y^.typ := x^.typ; yval^ := xval^
  509.                     END
  510.             | String:
  511.                     IF g = Char THEN CharToString(y); g := String
  512.                     ELSE err(100); y^.typ := x^.typ; yval^ := xval^
  513.                     END ;
  514.             | NilTyp:
  515.                     IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END
  516.             | Pointer:
  517.                     CheckPtr(x, y)
  518.             | ProcTyp:
  519.                     IF g # NilTyp THEN err(100) END
  520.             ELSE err(100); y^.typ := x^.typ; yval^ := xval^
  521.             END ;
  522.             f := x^.typ^.form
  523.         END ;    (* {x^.typ = y^.typ} *)
  524.         CASE op OF
  525.           times:
  526.                 IF f IN intSet THEN xv := xval^.intval; yv := yval^.intval;
  527.                     IF (xv = 0) OR (yv = 0) OR    (* division with negative numbers is not defined *)
  528.                         (xv > 0) & (yv > 0) & (yv <= MAX(LONGINT) DIV xv) OR
  529.                         (xv > 0) & (yv < 0) & (yv >= MIN(LONGINT) DIV xv) OR
  530.                         (xv < 0) & (yv > 0) & (xv >= MIN(LONGINT) DIV yv) OR
  531.                         (xv < 0) & (yv < 0) & (xv # MIN(LONGINT)) & (yv # MIN(LONGINT)) & (-xv <= MAX(LONGINT) DIV (-yv)) THEN
  532.                         xval^.intval := xv * yv; SetIntType(x)
  533.                     ELSE err(204)
  534.                     END
  535.                 ELSIF f IN realSet THEN
  536.                     temp := ABS(yval^.realval) <= 1.0;
  537.                     IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) / ABS(yval^.realval)) THEN
  538.                         xval^.realval := xval^.realval * yval^.realval; CheckRealType(f, 204, xval)
  539.                     ELSE err(204)
  540.                     END
  541.                 ELSIF f = Set THEN
  542.                     xval^.setval := xval^.setval * yval^.setval
  543.                 ELSIF f # Undef THEN err(101)
  544.                 END
  545.         | slash:
  546.                 IF f IN intSet THEN
  547.                     IF yval^.intval # 0 THEN
  548.                         xval^.realval := xval^.intval / yval^.intval; CheckRealType(Real, 205, xval)
  549.                     ELSE err(205); xval^.realval := 1.0
  550.                     END ;
  551.                     x^.typ := OPT.realtyp
  552.                 ELSIF f IN realSet THEN
  553.                     temp := ABS(yval^.realval) >= 1.0;
  554.                     IF temp OR (ABS(xval^.realval) <= MAX(LONGREAL) * ABS(yval^.realval)) THEN
  555.                         xval^.realval := xval^.realval / yval^.realval; CheckRealType(f, 205, xval)
  556.                     ELSE err(205)
  557.                     END
  558.                 ELSIF f = Set THEN
  559.                     xval^.setval := xval^.setval / yval^.setval
  560.                 ELSIF f # Undef THEN err(102)
  561.                 END
  562.         | div:
  563.                 IF f IN intSet THEN
  564.                     IF yval^.intval # 0 THEN
  565.                         xval^.intval := xval^.intval DIV yval^.intval; SetIntType(x)
  566.                     ELSE err(205)
  567.                     END
  568.                 ELSIF f # Undef THEN err(103)
  569.                 END
  570.         | mod:
  571.                 IF f IN intSet THEN
  572.                     IF yval^.intval # 0 THEN
  573.                         xval^.intval := xval^.intval MOD yval^.intval; SetIntType(x)
  574.                     ELSE err(205)
  575.                     END
  576.                 ELSIF f # Undef THEN err(104)
  577.                 END
  578.         | and:
  579.                 IF f = Bool THEN
  580.                     xval^.intval := BoolToInt(IntToBool(xval^.intval) & IntToBool(yval^.intval))
  581.                 ELSE err(94)
  582.                 END
  583.         | plus:
  584.                 IF f IN intSet THEN
  585.                     temp := (yval^.intval >= 0) & (xval^.intval <= MAX(LONGINT) - yval^.intval);
  586.                     IF temp OR (yval^.intval < 0) & (xval^.intval >= MIN(LONGINT) - yval^.intval) THEN 
  587.                             INC(xval^.intval, yval^.intval); SetIntType(x)
  588.                     ELSE err(206)
  589.                     END
  590.                 ELSIF f IN realSet THEN
  591.                     temp := (yval^.realval >= 0.0) & (xval^.realval <= MAX(LONGREAL) - yval^.realval);
  592.                     IF temp OR (yval^.realval < 0.0) & (xval^.realval >= -MAX(LONGREAL) - yval^.realval) THEN
  593.                             xval^.realval := xval^.realval + yval^.realval; CheckRealType(f, 206, xval)
  594.                     ELSE err(206)
  595.                     END
  596.                 ELSIF f = Set THEN
  597.                     xval^.setval := xval^.setval + yval^.setval
  598.                 ELSIF f # Undef THEN err(105)
  599.                 END
  600.         | minus:
  601.                 IF f IN intSet THEN
  602.                     IF (yval^.intval >= 0) & (xval^.intval >= MIN(LONGINT) + yval^.intval) OR
  603.                         (yval^.intval < 0) & (xval^.intval <= MAX(LONGINT) + yval^.intval) THEN 
  604.                             DEC(xval^.intval, yval^.intval); SetIntType(x)
  605.                     ELSE err(207)
  606.                     END
  607.                 ELSIF f IN realSet THEN
  608.                     temp := (yval^.realval >= 0.0) & (xval^.realval >= -MAX(LONGREAL) + yval^.realval);
  609.                     IF temp OR (yval^.realval < 0.0) & (xval^.realval <= MAX(LONGREAL) + yval^.realval) THEN
  610.                             xval^.realval := xval^.realval - yval^.realval; CheckRealType(f, 207, xval)
  611.                     ELSE err(207)
  612.                     END
  613.                 ELSIF f = Set THEN
  614.                     xval^.setval := xval^.setval - yval^.setval
  615.                 ELSIF f # Undef THEN err(106)
  616.                 END
  617.         | or:
  618.                 IF f = Bool THEN
  619.                     xval^.intval := BoolToInt(IntToBool(xval^.intval) OR IntToBool(yval^.intval))
  620.                 ELSE err(95)
  621.                 END
  622.         | eql:
  623.                 xval^.intval := BoolToInt(ConstCmp() = eql)
  624.         | neq:
  625.                 xval^.intval := BoolToInt(ConstCmp() # eql)
  626.         | lss:
  627.                 IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  628.                 ELSE xval^.intval := BoolToInt(ConstCmp() = lss)
  629.                 END
  630.         | leq:
  631.                 IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  632.                 ELSE xval^.intval := BoolToInt(ConstCmp() # gtr)
  633.                 END
  634.         | gtr:
  635.                 IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  636.                 ELSE xval^.intval := BoolToInt(ConstCmp() = gtr)
  637.                 END
  638.         | geq:
  639.                 IF f IN {Bool, Set, NilTyp, Pointer} THEN err(108)
  640.                 ELSE xval^.intval := BoolToInt(ConstCmp() # lss)
  641.                 END
  642.         END
  643.     END ConstOp;
  644.     PROCEDURE Convert(VAR x: OPT.Node; typ: OPT.Struct);
  645.         VAR node: OPT.Node; f, g: INTEGER; k: LONGINT; r: LONGREAL;
  646.     BEGIN f := x^.typ^.form; g := typ^.form;
  647.         IF x^.class = Nconst THEN
  648.             IF f IN intSet THEN
  649.                 IF g IN intSet THEN
  650.                     IF f > g THEN SetIntType(x);
  651.                         IF x^.typ^.form > g THEN err(203); x^.conval^.intval := 1 END
  652.                     END
  653.                 ELSIF g IN realSet THEN x^.conval^.realval := x^.conval^.intval; x^.conval^.intval := OPM.ConstNotAlloc
  654.                 ELSE (*g = Char*) k := x^.conval^.intval;
  655.                     IF (0 > k) OR (k > 0FFH) THEN err(220) END
  656.                 END
  657.             ELSIF f IN realSet THEN
  658.                 IF g IN realSet THEN CheckRealType(g, 203, x^.conval)
  659.                 ELSE (*g = LInt*)
  660.                     r := x^.conval^.realval;
  661.                     IF (r < MIN(LONGINT)) OR (r > MAX(LONGINT)) THEN err(203); r := 1 END ;
  662.                     x^.conval^.intval := ENTIER(r); SetIntType(x)
  663.                 END
  664.             ELSE (* (f IN {Char, Byte}) & (g IN {Byte} + intSet) OR (f = Undef) *)
  665.             END ;
  666.             x^.obj := NIL
  667.         ELSIF (x^.class = Nmop) & (x^.subcl = conv) & ((x^.left^.typ^.form < f) OR (f > g)) THEN
  668.             (* don't create new node *)
  669.             IF x^.left^.typ = typ THEN (* and suppress existing node *) x := x^.left END
  670.         ELSE node := OPT.NewNode(Nmop); node^.subcl := conv; node^.left := x; x := node
  671.         END ;
  672.         x^.typ := typ
  673.     END Convert;
  674.     PROCEDURE Op*(op: SHORTINT; VAR x: OPT.Node; y: OPT.Node);
  675.         VAR f, g: INTEGER; t, z: OPT.Node; typ: OPT.Struct; do: BOOLEAN; val: LONGINT;
  676.         PROCEDURE NewOp(op: SHORTINT; typ: OPT.Struct; VAR x: OPT.Node; y: OPT.Node);
  677.             VAR node: OPT.Node;
  678.         BEGIN
  679.             node := OPT.NewNode(Ndop); node^.subcl := op; node^.typ := typ;
  680.             node^.left := x; node^.right := y; x := node
  681.         END NewOp;
  682.         PROCEDURE strings(VAR x, y: OPT.Node): BOOLEAN;
  683.             VAR ok, xCharArr, yCharArr: BOOLEAN;
  684.         BEGIN
  685.             xCharArr := ((x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form=Char)) OR (f=String);
  686.             yCharArr := (((y^.typ^.comp IN {Array, DynArr}) & (y^.typ^.BaseTyp^.form=Char)) OR (g=String));
  687.             IF xCharArr & (g = Char) & (y^.class = Nconst) THEN CharToString(y); g := String; yCharArr := TRUE END ;
  688.             IF yCharArr & (f = Char) & (x^.class = Nconst) THEN CharToString(x); f := String; xCharArr := TRUE END ;
  689.             ok := xCharArr & yCharArr;
  690.             IF ok THEN    (* replace ""-string compare with 0X-char compare, if possible *)
  691.                 IF (f=String) & (x^.conval^.intval2 = 1) THEN    (* y is array of char *)
  692.                     x^.typ := OPT.chartyp; x^.conval^.intval := 0;
  693.                     Index(y, NewIntConst(0))
  694.                 ELSIF (g=String) & (y^.conval^.intval2 = 1) THEN    (* x is array of char *)
  695.                     y^.typ := OPT.chartyp; y^.conval^.intval := 0;
  696.                     Index(x, NewIntConst(0))
  697.                 END
  698.             END ;
  699.             RETURN ok
  700.         END strings;
  701.     BEGIN z := x;
  702.         IF (z^.class = Ntype) OR (z^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126)
  703.         ELSIF (z^.class = Nconst) & (y^.class = Nconst) THEN ConstOp(op, z, y); z^.obj := NIL
  704.         ELSE
  705.             IF z^.typ # y^.typ THEN
  706.                 g := y^.typ^.form;
  707.                 CASE z^.typ^.form OF
  708.                    Char:
  709.                         IF z^.class = Nconst THEN CharToString(z) ELSE err(100) END
  710.                 | SInt:
  711.                         IF g IN intSet + realSet THEN Convert(z, y^.typ)
  712.                         ELSE  err(100)
  713.                         END
  714.                 | Int:
  715.                         IF g = SInt THEN Convert(y, z^.typ)
  716.                         ELSIF g IN intSet + realSet THEN Convert(z, y^.typ)
  717.                         ELSE  err(100)
  718.                         END
  719.                 | LInt:
  720.                         IF g IN intSet THEN Convert(y, z^.typ)
  721.                         ELSIF g IN realSet THEN Convert(z, y^.typ)
  722.                         ELSE  err(100)
  723.                         END
  724.                 | Real:
  725.                         IF g IN intSet THEN Convert(y, z^.typ)
  726.                         ELSIF g IN realSet THEN Convert(z, y^.typ)
  727.                         ELSE  err(100)
  728.                         END
  729.                 | LReal:
  730.                         IF g IN intSet + realSet THEN Convert(y, z^.typ)
  731.                         ELSIF g IN realSet THEN Convert(y, z^.typ)
  732.                         ELSE  err(100)
  733.                         END
  734.                 | NilTyp:
  735.                         IF ~(g IN {Pointer, ProcTyp}) THEN err(100) END
  736.                 | Pointer:
  737.                         CheckPtr(z, y)
  738.                 | ProcTyp:
  739.                         IF g # NilTyp THEN err(100) END
  740.                 | String:
  741.                 | Comp:
  742.                         IF z^.typ^.comp = Record THEN err(100) END
  743.                 ELSE err(100)
  744.                 END
  745.             END ;    (* {z^.typ = y^.typ} *)
  746.             typ := z^.typ; f := typ^.form; g := y^.typ^.form;
  747.             CASE op OF
  748.               times:
  749.                     do := TRUE;
  750.                     IF f IN intSet THEN
  751.                         IF z^.class = Nconst THEN val := z^.conval^.intval;
  752.                             IF val = 1 THEN do := FALSE; z := y
  753.                             ELSIF val = 0 THEN do := FALSE
  754.                             ELSIF log(val) = 1 THEN
  755.                                 t := y; y := z; z := t;
  756.                                 op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL
  757.                             END
  758.                         ELSIF y^.class = Nconst THEN val := y^.conval^.intval;
  759.                             IF val = 1 THEN do := FALSE
  760.                             ELSIF val = 0 THEN do := FALSE; z := y
  761.                             ELSIF log(val) = 1 THEN
  762.                                 op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := exp; y^.obj := NIL
  763.                             END
  764.                         END
  765.                     ELSIF ~(f IN {Undef, Real..Set}) THEN err(105); typ := OPT.undftyp
  766.                     END ;
  767.                     IF do THEN NewOp(op, typ, z, y) END
  768.             | slash:
  769.                     IF f IN intSet THEN
  770.                         IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN err(205) END ;
  771.                         Convert(z, OPT.realtyp); Convert(y, OPT.realtyp);
  772.                         typ := OPT.realtyp
  773.                     ELSIF f IN realSet THEN
  774.                         IF (y^.class = Nconst) & (y^.conval^.realval = 0.0) THEN err(205) END
  775.                     ELSIF (f # Set) & (f # Undef) THEN err(102); typ := OPT.undftyp
  776.                     END ;
  777.                     NewOp(op, typ, z, y)
  778.             | div:
  779.                     do := TRUE;
  780.                     IF f IN intSet THEN
  781.                         IF y^.class = Nconst THEN val := y^.conval^.intval;
  782.                             IF val = 0 THEN err(205)
  783.                             ELSIF val = 1 THEN do := FALSE
  784.                             ELSIF log(val) = 1 THEN
  785.                                 op := ash; y^.typ := OPT.sinttyp; y^.conval^.intval := -exp; y^.obj := NIL
  786.                             END
  787.                         END
  788.                     ELSIF f # Undef THEN err(103); typ := OPT.undftyp
  789.                     END ;
  790.                     IF do THEN NewOp(op, typ, z, y) END
  791.             | mod:
  792.                     IF f IN intSet THEN
  793.                         IF y^.class = Nconst THEN
  794.                             IF y^.conval^.intval = 0 THEN err(205)
  795.                             ELSIF log(y^.conval^.intval) = 1 THEN
  796.                                 op := msk; y^.conval^.intval := ASH(-1, exp); y^.obj := NIL
  797.                             END
  798.                         END
  799.                     ELSIF f # Undef THEN err(104); typ := OPT.undftyp
  800.                     END ;
  801.                     NewOp(op, typ, z, y)
  802.             | and:
  803.                     IF f = Bool THEN
  804.                         IF z^.class = Nconst THEN
  805.                             IF IntToBool(z^.conval^.intval) THEN z := y END
  806.                         ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN (* optimize z & TRUE -> z *)
  807.                 (*    ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN
  808.                             don't optimize z & FALSE -> FALSE: side effects possible    *)
  809.                         ELSE NewOp(op, typ, z, y)
  810.                         END
  811.                     ELSIF f # Undef THEN err(94); z^.typ := OPT.undftyp
  812.                     END
  813.             | plus:
  814.                     IF ~(f IN {Undef, SInt..Set}) THEN err(105); typ := OPT.undftyp END ;
  815.                     do := TRUE;
  816.                     IF f IN intSet THEN
  817.                         IF (z^.class = Nconst) & (z^.conval^.intval = 0) THEN do := FALSE; z := y END ;
  818.                         IF (y^.class = Nconst) & (y^.conval^.intval = 0) THEN do := FALSE END
  819.                     END ;
  820.                     IF do THEN NewOp(op, typ, z, y) END
  821.             | minus:
  822.                     IF ~(f IN {Undef, SInt..Set}) THEN err(106); typ := OPT.undftyp END ;
  823.                     IF ~(f IN intSet) OR (y^.class # Nconst) OR (y^.conval^.intval # 0) THEN NewOp(op, typ, z, y) END
  824.             | or:
  825.                     IF f = Bool THEN
  826.                         IF z^.class = Nconst THEN
  827.                             IF ~IntToBool(z^.conval^.intval) THEN z := y END
  828.                         ELSIF (y^.class = Nconst) & ~IntToBool(y^.conval^.intval) THEN (* optimize z OR FALSE -> z *)
  829.                 (*    ELSIF (y^.class = Nconst) & IntToBool(y^.conval^.intval) THEN
  830.                             don't optimize z OR TRUE -> TRUE: side effects possible    *)
  831.                         ELSE NewOp(op, typ, z, y)
  832.                         END
  833.                     ELSIF f # Undef THEN err(95); z^.typ := OPT.undftyp
  834.                     END
  835.             | eql, neq:
  836.                     IF (f IN {Undef..Set, NilTyp, Pointer, ProcTyp}) OR strings(z, y) THEN typ := OPT.booltyp
  837.                     ELSE err(107); typ := OPT.undftyp
  838.                     END ;
  839.                     NewOp(op, typ, z, y)
  840.             | lss, leq, gtr, geq:
  841.                     IF (f IN {Undef, Char..LReal}) OR strings(z, y) THEN typ := OPT.booltyp
  842.                     ELSE err(108); typ := OPT.undftyp
  843.                     END ;
  844.                     NewOp(op, typ, z, y)
  845.             END
  846.         END ;
  847.         x := z
  848.     END Op;
  849.     PROCEDURE SetRange*(VAR x: OPT.Node; y: OPT.Node);
  850.         VAR k, l: LONGINT;
  851.     BEGIN
  852.         IF (x^.class = Ntype) OR (x^.class = Nproc) OR (y^.class = Ntype) OR (y^.class = Nproc) THEN err(126)    
  853.         ELSIF (x^.typ^.form IN intSet) & (y^.typ^.form IN intSet) THEN
  854.             IF x^.class = Nconst THEN
  855.                 k := x^.conval^.intval;
  856.                 IF (0 > k) OR (k > OPM.MaxSet) THEN err(202) END
  857.             END ;
  858.             IF y^.class = Nconst THEN
  859.                 l := y^.conval^.intval;
  860.                 IF (0 > l) OR (l > OPM.MaxSet) THEN err(202) END
  861.             END ;
  862.             IF (x^.class = Nconst) & (y^.class = Nconst) THEN
  863.                 IF k <= l THEN
  864.                     x^.conval^.setval := {k..l}
  865.                 ELSE err(201); x^.conval^.setval := {l..k}
  866.                 END ;
  867.                 x^.obj := NIL
  868.             ELSE BindNodes(Nupto, OPT.settyp, x, y)
  869.             END
  870.         ELSE err(93)
  871.         END ;
  872.         x^.typ := OPT.settyp
  873.     END SetRange;
  874.     PROCEDURE SetElem*(VAR x: OPT.Node);
  875.         VAR k: LONGINT;
  876.     BEGIN
  877.         IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  878.         ELSIF ~(x^.typ^.form IN intSet) THEN err(93)
  879.         ELSIF x^.class = Nconst THEN
  880.             k := x^.conval^.intval;
  881.             IF (0 <= k) & (k <= OPM.MaxSet) THEN x^.conval^.setval := {k}
  882.             ELSE err(202)
  883.             END ;
  884.             x^.obj := NIL
  885.         ELSE Convert(x, OPT.settyp)
  886.         END ;
  887.         x^.typ := OPT.settyp
  888.     END SetElem;
  889.     PROCEDURE CheckAssign(x: OPT.Struct; ynode: OPT.Node);    (* x := y *)
  890.         VAR f, g: INTEGER; y, p, q: OPT.Struct;
  891.     BEGIN
  892.         y := ynode^.typ; f := x^.form; g := y^.form;
  893.         IF (ynode^.class = Ntype) OR (ynode^.class = Nproc) & (f # ProcTyp) THEN err(126) END ;
  894.         CASE f OF
  895.           Undef, String:
  896.         | Byte:
  897.                 IF ~(g IN {Byte, Char, SInt}) THEN err(113) END
  898.         | Bool, Char, SInt, Set:
  899.                 IF g # f THEN err(113) END
  900.         | Int:
  901.                 IF ~(g IN {SInt, Int}) THEN err(113) END
  902.         | LInt:
  903.                 IF ~(g IN intSet) THEN err(113) END
  904.         | Real:
  905.                 IF ~(g IN {SInt..Real}) THEN err(113) END
  906.         | LReal:
  907.                 IF ~(g IN {SInt..LReal}) THEN err(113) END
  908.         | Pointer:
  909.                 IF (x = y) OR (g = NilTyp) OR (x = OPT.sysptrtyp) & (g = Pointer) THEN (* ok *)
  910.                 ELSIF g = Pointer THEN
  911.                     p := x^.BaseTyp; q := y^.BaseTyp;
  912.                     IF (p^.comp = Record) & (q^.comp = Record) THEN
  913.                         WHILE (q # p) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ;
  914.                         IF q = NIL THEN err(113) END
  915.                     ELSE err(113)
  916.                     END
  917.                 ELSE err(113)
  918.                 END
  919.         | ProcTyp:
  920.                 IF ynode^.class = Nproc THEN CheckProc(x, ynode^.obj)
  921.                 ELSIF (x = y) OR (g = NilTyp) THEN (* ok *)
  922.                 ELSE err(113)
  923.                 END
  924.         | NoTyp, NilTyp:
  925.                 err(113)
  926.         | Comp:
  927.                 IF x^.comp = Array THEN
  928.                     IF (ynode^.class = Nconst) & (g = Char) THEN CharToString(ynode); y := ynode^.typ; g := String END ;
  929.                     IF x = y THEN (* ok *)
  930.                     ELSIF (g = String) & (x^.BaseTyp = OPT.chartyp) THEN (*check length of string*)
  931.                         IF ynode^.conval^.intval2 > x^.n THEN err(114) END ;
  932.                     ELSE err(113)
  933.                     END
  934.                 ELSIF x^.comp = Record THEN
  935.                     IF x = y THEN (* ok *)
  936.                     ELSIF y^.comp = Record THEN
  937.                         q := y^.BaseTyp;
  938.                         WHILE (q # NIL) & (q # x) & (q # OPT.undftyp) DO q := q^.BaseTyp END ;
  939.                         IF q = NIL THEN err(113) END
  940.                     ELSE err(113)
  941.                     END
  942.                 ELSE (*DynArr*) err(113)
  943.                 END
  944.         END ;
  945.         IF (ynode^.class = Nconst) & (g < f) & (g IN {SInt..Real}) & (f IN {Int..LReal}) THEN
  946.             Convert(ynode, x)
  947.         END
  948.     END CheckAssign;
  949.     PROCEDURE CheckLeaf(x: OPT.Node; dynArrToo: BOOLEAN);
  950.     BEGIN
  951.         IF (x^.class = Nmop) & (x^.subcl = val) THEN x := x^.left END ;
  952.         IF x^.class = Nguard THEN x := x^.left END ;    (* skip last (and unique) guard *)
  953.         IF (x^.class = Nvar) & (dynArrToo OR (x^.typ^.comp # DynArr)) THEN x^.obj^.leaf := FALSE END
  954.     END CheckLeaf;
  955.     PROCEDURE StPar0*(VAR par0: OPT.Node; fctno: INTEGER);    (* par0: first param of standard proc *)
  956.         VAR f: INTEGER; typ: OPT.Struct; x: OPT.Node;
  957.     BEGIN x := par0; f := x^.typ^.form;
  958.         CASE fctno OF
  959.           haltfn: (*HALT*)
  960.                 IF (f IN intSet) & (x^.class = Nconst) THEN
  961.                     IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN
  962.                         BindNodes(Ntrap, OPT.notyp, x, x)
  963.                     ELSE err(218)
  964.                     END
  965.                 ELSE err(69)
  966.                 END ;
  967.                 x^.typ := OPT.notyp
  968.         | newfn: (*NEW*)
  969.                 typ := OPT.notyp;
  970.                 IF NotVar(x) THEN err(112)
  971.                 ELSIF f = Pointer THEN
  972.                     IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END ;
  973.                     IF x^.readonly THEN err(76) END ;
  974.                     f := x^.typ^.BaseTyp^.comp;
  975.                     IF f IN {Record, DynArr, Array} THEN
  976.                         IF f = DynArr THEN typ := x^.typ^.BaseTyp END ;
  977.                         BindNodes(Nassign, OPT.notyp, x, NIL); x^.subcl := newfn
  978.                     ELSE err(111)
  979.                     END
  980.                 ELSE err(111)
  981.                 END ;
  982.                 x^.typ := typ
  983.         | absfn: (*ABS*)
  984.                 MOp(abs, x)
  985.         | capfn: (*CAP*)
  986.                 MOp(cap, x)
  987.         | ordfn: (*ORD*) 
  988.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  989.                 ELSIF f = Char THEN Convert(x, OPT.inttyp)
  990.                 ELSE err(111)
  991.                 END ;
  992.                 x^.typ := OPT.inttyp
  993.         | entierfn: (*ENTIER*)
  994.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  995.                 ELSIF f IN realSet THEN Convert(x, OPT.linttyp)
  996.                 ELSE err(111)
  997.                 END ;
  998.                 x^.typ := OPT.linttyp
  999.         | oddfn: (*ODD*)
  1000.                 MOp(odd, x)
  1001.         | minfn: (*MIN*)
  1002.                 IF x^.class = Ntype THEN
  1003.                     CASE f OF
  1004.                       Bool:  x := NewBoolConst(FALSE)
  1005.                     | Char:  x := NewIntConst(0); x^.typ := OPT.chartyp
  1006.                     | SInt:  x := NewIntConst(OPM.MinSInt)
  1007.                     | Int:   x := NewIntConst(OPM.MinInt)
  1008.                     | LInt:  x := NewIntConst(OPM.MinLInt)
  1009.                     | Set:   x := NewIntConst(0); x^.typ := OPT.inttyp
  1010.                     | Real:  x := NewRealConst(OPM.MinReal, OPT.realtyp)
  1011.                     | LReal: x := NewRealConst(OPM.MinLReal, OPT.lrltyp)
  1012.                     ELSE err(111)
  1013.                     END
  1014.                 ELSE err(110)
  1015.                 END
  1016.         | maxfn: (*MAX*)
  1017.                 IF x^.class = Ntype THEN
  1018.                     CASE f OF
  1019.                       Bool:  x := NewBoolConst(TRUE)
  1020.                     | Char:  x := NewIntConst(0FFH); x^.typ := OPT.chartyp
  1021.                     | SInt:  x := NewIntConst(OPM.MaxSInt)
  1022.                     | Int:   x := NewIntConst(OPM.MaxInt)
  1023.                     | LInt:  x := NewIntConst(OPM.MaxLInt)
  1024.                     | Set:   x := NewIntConst(OPM.MaxSet); x^.typ := OPT.inttyp
  1025.                     | Real:  x := NewRealConst(OPM.MaxReal, OPT.realtyp)
  1026.                     | LReal: x := NewRealConst(OPM.MaxLReal, OPT.lrltyp)
  1027.                     ELSE err(111)
  1028.                     END
  1029.                 ELSE err(110)
  1030.                 END
  1031.         | chrfn: (*CHR*) 
  1032.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1033.                 ELSIF f IN {Undef, SInt..LInt} THEN Convert(x, OPT.chartyp)
  1034.                 ELSE err(111); x^.typ := OPT.chartyp
  1035.                 END
  1036.         | shortfn: (*SHORT*)
  1037.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1038.                 ELSIF f = Int THEN Convert(x, OPT.sinttyp)
  1039.                 ELSIF f = LInt THEN Convert(x, OPT.inttyp)
  1040.                 ELSIF f = LReal THEN Convert(x, OPT.realtyp)
  1041.                 ELSE err(111)
  1042.                 END
  1043.         | longfn: (*LONG*)
  1044.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1045.                 ELSIF f = SInt THEN Convert(x, OPT.inttyp)
  1046.                 ELSIF f = Int THEN Convert(x, OPT.linttyp)
  1047.                 ELSIF f = Real THEN Convert(x, OPT.lrltyp)
  1048.                 ELSIF f = Char THEN Convert(x, OPT.linttyp)
  1049.                 ELSE err(111)
  1050.                 END
  1051.         | incfn, decfn: (*INC, DEC*) 
  1052.                 IF NotVar(x) THEN err(112)
  1053.                 ELSIF ~(f IN intSet) THEN err(111)
  1054.                 ELSIF x^.readonly THEN err(76)
  1055.                 END
  1056.         | inclfn, exclfn: (*INCL, EXCL*)
  1057.                 IF NotVar(x) THEN err(112)
  1058.                 ELSIF x^.typ # OPT.settyp THEN err(111); x^.typ := OPT.settyp
  1059.                 ELSIF x^.readonly THEN err(76)
  1060.                 END
  1061.         | lenfn: (*LEN*)
  1062.                 IF ~(x^.typ^.comp IN {DynArr, Array}) THEN err(131) END
  1063.         | copyfn: (*COPY*)
  1064.                 IF (x^.class = Nconst) & (f = Char) THEN CharToString(x); f := String END ;
  1065.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1066.                 ELSIF (~(x^.typ^.comp IN {DynArr, Array}) OR (x^.typ^.BaseTyp^.form # Char))
  1067.                      & (f # String) THEN err(111)
  1068.                 END
  1069.         | ashfn: (*ASH*)
  1070.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1071.                 ELSIF f IN intSet THEN
  1072.                     IF f # LInt THEN Convert(x, OPT.linttyp) END
  1073.                 ELSE err(111); x^.typ := OPT.linttyp
  1074.                 END
  1075.         | adrfn: (*SYSTEM.ADR*)
  1076.                 CheckLeaf(x, FALSE); MOp(adr, x)
  1077.         | sizefn: (*SIZE*)
  1078.                 IF x^.class # Ntype THEN err(110); x := NewIntConst(1)
  1079.                 ELSIF (f IN {Byte..Set, Pointer, ProcTyp}) OR (x^.typ^.comp IN {Array, Record}) THEN
  1080.                     typSize(x^.typ, FALSE); x := NewIntConst(x^.typ^.size)
  1081.                 ELSE err(111); x := NewIntConst(1)
  1082.                 END
  1083.         | ccfn: (*SYSTEM.CC*)
  1084.                 MOp(cc, x)
  1085.         | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
  1086.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1087.                 ELSIF ~(f IN intSet + {Byte, Char, Set}) THEN err(111)
  1088.                 END
  1089.         | getfn, putfn, bitfn, movefn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.BIT, SYSTEM.MOVE*)
  1090.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1091.                 ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp)
  1092.                 ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp
  1093.                 END
  1094.         | getrfn, putrfn: (*SYSTEM.GETREG, SYSTEM.PUTREG*)
  1095.                 IF (f IN intSet) & (x^.class = Nconst) THEN
  1096.                     IF (x^.conval^.intval < OPM.MinRegNr) OR (x^.conval^.intval > OPM.MaxRegNr) THEN err(220) END
  1097.                 ELSE err(69)
  1098.                 END
  1099.         | valfn: (*SYSTEM.VAL*)
  1100.                 IF x^.class # Ntype THEN err(110)
  1101.                 ELSIF (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(111)
  1102.                 END
  1103.         | sysnewfn: (*SYSTEM.NEW*)
  1104.                 IF NotVar(x) THEN err(112)
  1105.                 ELSIF f = Pointer THEN
  1106.                     IF OPM.NEWusingAdr THEN CheckLeaf(x, TRUE) END
  1107.                 ELSE err(111)
  1108.                 END
  1109.         | assertfn: (*ASSERT*)
  1110.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); x := NewBoolConst(FALSE)
  1111.                 ELSIF f # Bool THEN err(120); x := NewBoolConst(FALSE)
  1112.                 ELSE MOp(not, x)
  1113.                 END
  1114.         END ;
  1115.         par0 := x
  1116.     END StPar0;
  1117.     PROCEDURE StPar1*(VAR par0: OPT.Node; x: OPT.Node; fctno: SHORTINT);    (* x: second parameter of standard proc *)
  1118.         VAR f, L: INTEGER; typ: OPT.Struct; p, t: OPT.Node;
  1119.         PROCEDURE NewOp(class, subcl: SHORTINT; left, right: OPT.Node): OPT.Node;
  1120.             VAR node: OPT.Node;
  1121.         BEGIN
  1122.             node := OPT.NewNode(class); node^.subcl := subcl;
  1123.             node^.left := left; node^.right := right; RETURN node
  1124.         END NewOp;
  1125.     BEGIN p := par0; f := x^.typ^.form;
  1126.         CASE fctno OF
  1127.           incfn, decfn: (*INC DEC*)
  1128.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126); p^.typ := OPT.notyp
  1129.                 ELSE
  1130.                     IF x^.typ # p^.typ THEN
  1131.                         IF (x^.class = Nconst) & (f IN intSet) THEN Convert(x, p^.typ)
  1132.                         ELSE err(111)
  1133.                         END
  1134.                     END ;
  1135.                     p := NewOp(Nassign, fctno, p, x);
  1136.                     p^.typ := OPT.notyp
  1137.                 END
  1138.         | inclfn, exclfn: (*INCL, EXCL*)
  1139.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1140.                 ELSIF f IN intSet THEN
  1141.                     IF (x^.class = Nconst) & ((0 > x^.conval^.intval) OR (x^.conval^.intval > OPM.MaxSet)) THEN err(202)
  1142.                     END ;
  1143.                     p := NewOp(Nassign, fctno, p, x)
  1144.                 ELSE err(111)
  1145.                 END ;
  1146.                 p^.typ := OPT.notyp
  1147.         | lenfn: (*LEN*)
  1148.                 IF ~(f IN intSet) OR (x^.class # Nconst) THEN err(69)
  1149.                 ELSIF f = SInt THEN
  1150.                     L := SHORT(x^.conval^.intval); typ := p^.typ;
  1151.                     WHILE (L > 0) & (typ^.comp IN {DynArr, Array}) DO typ := typ^.BaseTyp; DEC(L) END ;
  1152.                     IF (L # 0) OR ~(typ^.comp IN {DynArr, Array}) THEN err(132)
  1153.                     ELSE x^.obj := NIL;
  1154.                         IF typ^.comp = DynArr THEN
  1155.                             WHILE p^.class = Nindex DO p := p^.left; INC(x^.conval^.intval) END ;    (* possible side effect ignored *)
  1156.                             p := NewOp(Ndop, len, p, x); p^.typ := OPT.linttyp
  1157.                         ELSE p := x; p^.conval^.intval := typ^.n; SetIntType(p)
  1158.                         END
  1159.                     END
  1160.                 ELSE err(132)
  1161.                 END
  1162.         | copyfn: (*COPY*)
  1163.                 IF NotVar(x) THEN err(112)
  1164.                 ELSIF (x^.typ^.comp IN {Array, DynArr}) & (x^.typ^.BaseTyp^.form = Char) THEN
  1165.                     IF x^.readonly THEN err(76) END ;
  1166.                     t := x; x := p; p := t; p := NewOp(Nassign, copyfn, p, x)
  1167.                 ELSE err(111)
  1168.                 END ;
  1169.                 p^.typ := OPT.notyp
  1170.         | ashfn: (*ASH*)
  1171.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1172.                 ELSIF f IN intSet THEN
  1173.                     IF (p^.class = Nconst) & (x^.class = Nconst) THEN
  1174.                         IF (-maxExp > x^.conval^.intval) OR (x^.conval^.intval > maxExp) THEN err(208); p^.conval^.intval := 1
  1175.                         ELSIF x^.conval^.intval >= 0 THEN
  1176.                             IF ABS(p^.conval^.intval) <= MAX(LONGINT) DIV ASH(1, x^.conval^.intval) THEN
  1177.                                 p^.conval^.intval := p^.conval^.intval * ASH(1, x^.conval^.intval)
  1178.                             ELSE err(208); p^.conval^.intval := 1
  1179.                             END
  1180.                         ELSE p^.conval^.intval := ASH(p^.conval^.intval, x^.conval^.intval)
  1181.                         END ;
  1182.                         p^.obj := NIL
  1183.                     ELSE p := NewOp(Ndop, ash, p, x); p^.typ := OPT.linttyp
  1184.                     END
  1185.                 ELSE err(111)
  1186.                 END
  1187.         | newfn: (*NEW(p, x...)*)
  1188.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1189.                 ELSIF p^.typ^.comp = DynArr THEN
  1190.                     IF f IN intSet THEN
  1191.                         IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END
  1192.                     ELSE err(111)
  1193.                     END ;
  1194.                     p^.right := x; p^.typ := p^.typ^.BaseTyp
  1195.                 ELSE err(64)
  1196.                 END
  1197.         | lshfn, rotfn: (*SYSTEM.LSH, SYSTEM.ROT*)
  1198.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1199.                 ELSIF ~(f IN intSet) THEN err(111)
  1200.                 ELSE
  1201.                     IF fctno = lshfn THEN p := NewOp(Ndop, lsh, p, x) ELSE p := NewOp(Ndop, rot, p, x) END ;
  1202.                     p^.typ := p^.left^.typ
  1203.                 END
  1204.         | getfn, putfn, getrfn, putrfn: (*SYSTEM.GET, SYSTEM.PUT, SYSTEM.GETREG, SYSTEM.PUTREG*)
  1205.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1206.                 ELSIF f IN {Undef..Set, Pointer, ProcTyp} THEN
  1207.                     IF (fctno = getfn) OR (fctno = getrfn) THEN
  1208.                         IF NotVar(x) THEN err(112) END ;
  1209.                         t := x; x := p; p := t
  1210.                     END ;
  1211.                     p := NewOp(Nassign, fctno, p, x)
  1212.                 ELSE err(111)
  1213.                 END ;
  1214.                 p^.typ := OPT.notyp
  1215.         | bitfn: (*SYSTEM.BIT*)
  1216.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1217.                 ELSIF f IN intSet THEN
  1218.                     p := NewOp(Ndop, bit, p, x)
  1219.                 ELSE err(111)
  1220.                 END ;
  1221.                 p^.typ := OPT.booltyp
  1222.         | valfn: (*SYSTEM.VAL*)    (* type is changed without considering the byte ordering on the target machine *)
  1223.                 IF (x^.class = Ntype) OR (x^.class = Nproc) OR
  1224.                     (f IN {Undef, String, NoTyp}) OR (x^.typ^.comp = DynArr) THEN err(126)
  1225.                 END ;
  1226.                 IF (x^.class >= Nconst) OR ((f IN realSet) # (p^.typ^.form IN realSet)) THEN
  1227.                     t := OPT.NewNode(Nmop); t^.subcl := val; t^.left := x; x := t
  1228.                 ELSE x^.readonly := FALSE
  1229.                 END ;
  1230.                 x^.typ := p^.typ; p := x
  1231.         | sysnewfn: (*SYSTEM.NEW*)
  1232.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1233.                 ELSIF f IN intSet THEN
  1234.                     p := NewOp(Nassign, sysnewfn, p, x)
  1235.                 ELSE err(111)
  1236.                 END ;
  1237.                 p^.typ := OPT.notyp
  1238.         | movefn: (*SYSTEM.MOVE*)
  1239.                 IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1240.                 ELSIF (x^.class = Nconst) & (f IN {SInt, Int}) THEN Convert(x, OPT.linttyp)
  1241.                 ELSIF ~(f IN {LInt, Pointer}) THEN err(111); x^.typ := OPT.linttyp
  1242.                 END ;
  1243.                 p^.link := x
  1244.         | assertfn: (*ASSERT*)
  1245.                 IF (f IN intSet) & (x^.class = Nconst) THEN
  1246.                     IF (OPM.MinHaltNr <= x^.conval^.intval) & (x^.conval^.intval <= OPM.MaxHaltNr) THEN
  1247.                         BindNodes(Ntrap, OPT.notyp, x, x);
  1248.                         x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos;
  1249.                         Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos;
  1250.                         Construct(Nifelse, p, NIL); OptIf(p);
  1251.                         IF p = NIL THEN    (* ASSERT(TRUE) *)
  1252.                         ELSIF p^.class = Ntrap THEN err(99)
  1253.                         ELSE p^.subcl := assertfn
  1254.                         END
  1255.                     ELSE err(218)
  1256.                     END
  1257.                 ELSE err(69)
  1258.                 END
  1259.         ELSE err(64)
  1260.         END ;
  1261.         par0 := p
  1262.     END StPar1;
  1263.     PROCEDURE StParN*(VAR par0: OPT.Node; x: OPT.Node; fctno, n: INTEGER);    (* x: n+1-th param of standard proc *)
  1264.         VAR node: OPT.Node; f: INTEGER; p: OPT.Node;
  1265.     BEGIN p := par0; f := x^.typ^.form;
  1266.         IF fctno = newfn THEN (*NEW(p, ..., x...*)
  1267.             IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1268.             ELSIF p^.typ^.comp # DynArr THEN err(64)
  1269.             ELSIF f IN intSet THEN
  1270.                 IF (x^.class = Nconst) & ((x^.conval^.intval <= 0) OR (x^.conval^.intval > OPM.MaxIndex)) THEN err(63) END ;
  1271.                 node := p^.right; WHILE node^.link # NIL DO node := node^.link END;
  1272.                 node^.link := x; p^.typ := p^.typ^.BaseTyp
  1273.             ELSE err(111)
  1274.             END
  1275.         ELSIF (fctno = movefn) & (n = 2) THEN (*SYSTEM.MOVE*)
  1276.             IF (x^.class = Ntype) OR (x^.class = Nproc) THEN err(126)
  1277.             ELSIF f IN intSet THEN
  1278.                 node := OPT.NewNode(Nassign); node^.subcl := movefn; node^.right := p;
  1279.                 node^.left := p^.link; p^.link := x; p := node
  1280.             ELSE err(111)
  1281.             END ;
  1282.             p^.typ := OPT.notyp
  1283.         ELSE err(64)
  1284.         END ;
  1285.         par0 := p
  1286.     END StParN;
  1287.     PROCEDURE StFct*(VAR par0: OPT.Node; fctno: SHORTINT; parno: INTEGER);
  1288.         VAR dim: INTEGER; x, p: OPT.Node;
  1289.     BEGIN p := par0;
  1290.         IF fctno <= ashfn THEN
  1291.             IF (fctno = newfn) & (p^.typ # OPT.notyp) THEN
  1292.                 IF p^.typ^.comp = DynArr THEN err(65) END ;
  1293.                 p^.typ := OPT.notyp
  1294.             ELSIF fctno <= sizefn THEN (* 1 param *)
  1295.                 IF parno < 1 THEN err(65) END
  1296.             ELSE (* more than 1 param *)
  1297.                 IF ((fctno = incfn) OR (fctno = decfn)) & (parno = 1) THEN (*INC, DEC*)
  1298.                     BindNodes(Nassign, OPT.notyp, p, NewIntConst(1)); p^.subcl := fctno
  1299.                 ELSIF (fctno = lenfn) & (parno = 1) THEN (*LEN*)
  1300.                     IF p^.typ^.comp = DynArr THEN dim := 0;
  1301.                         WHILE p^.class = Nindex DO p := p^.left; INC(dim) END ;    (* possible side effect ignored *)
  1302.                         BindNodes(Ndop, OPT.linttyp, p, NewIntConst(dim)); p^.subcl := len
  1303.                     ELSE
  1304.                         p := NewIntConst(p^.typ^.n)
  1305.                     END
  1306.                 ELSIF parno < 2 THEN err(65)
  1307.                 END
  1308.             END
  1309.         ELSIF fctno = assertfn THEN
  1310.             IF parno = 1 THEN x := NIL;
  1311.                 BindNodes(Ntrap, OPT.notyp, x, NewIntConst(AssertTrap));
  1312.                 x^.conval := OPT.NewConst(); x^.conval^.intval := OPM.errpos;
  1313.                 Construct(Nif, p, x); p^.conval := OPT.NewConst(); p^.conval^.intval := OPM.errpos;
  1314.                 Construct(Nifelse, p, NIL); OptIf(p);
  1315.                 IF p = NIL THEN    (* ASSERT(TRUE) *)
  1316.                 ELSIF p^.class = Ntrap THEN err(99)
  1317.                 ELSE p^.subcl := assertfn
  1318.                 END
  1319.             ELSIF parno < 1 THEN err(65)
  1320.             END
  1321.         ELSE (*SYSTEM*)
  1322.             IF (parno < 1) OR
  1323.                 (fctno > ccfn) & (parno < 2) OR
  1324.                 (fctno = movefn) & (parno < 3) THEN err(65)
  1325.             END
  1326.         END ;
  1327.         par0 := p
  1328.     END StFct;
  1329.     PROCEDURE DynArrParCheck(ftyp, atyp: OPT.Struct; fvarpar: BOOLEAN);
  1330.         VAR f: INTEGER;
  1331.     BEGIN (* ftyp^.comp = DynArr *)
  1332.         f := atyp^.comp; ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp;
  1333.         IF fvarpar & (ftyp = OPT.bytetyp) THEN (* ok, but ... *)
  1334.             IF ~(f IN {Array, DynArr}) OR ~(atyp^.form IN {Byte..SInt}) THEN err(-301) END (* ... warning 301 *)
  1335.         ELSIF f IN {Array, DynArr} THEN
  1336.             IF ftyp^.comp = DynArr THEN DynArrParCheck(ftyp, atyp, fvarpar)
  1337.             ELSIF ftyp # atyp THEN
  1338.                 IF ~fvarpar & (ftyp.form = Pointer) & (atyp.form = Pointer) THEN
  1339.                     ftyp := ftyp^.BaseTyp; atyp := atyp^.BaseTyp;
  1340.                     IF (ftyp^.comp = Record) & (atyp^.comp = Record) THEN
  1341.                         WHILE (ftyp # atyp) & (atyp # NIL) & (atyp # OPT.undftyp) DO atyp := atyp^.BaseTyp END ;
  1342.                         IF atyp = NIL THEN err(113) END
  1343.                     ELSE err(66)
  1344.                     END
  1345.                 ELSE err(66)
  1346.                 END
  1347.             END ;
  1348.         ELSE err(67)
  1349.         END
  1350.     END DynArrParCheck;
  1351.     PROCEDURE CheckReceiver(VAR x: OPT.Node; fp: OPT.Object);
  1352.     BEGIN
  1353.         IF fp^.typ^.form = Pointer THEN
  1354.             IF x^.class = Nderef THEN x := x^.left (*undo DeRef*) ELSE (*x^.typ^.comp = Record*) err(71) END
  1355.         END
  1356.     END CheckReceiver;
  1357.     PROCEDURE PrepCall*(VAR x: OPT.Node; VAR fpar: OPT.Object);
  1358.     BEGIN
  1359.         IF (x^.obj # NIL) & (x^.obj^.mode IN {LProc, XProc, TProc, CProc}) THEN
  1360.             fpar := x^.obj^.link;
  1361.             IF x^.obj^.mode = TProc THEN CheckReceiver(x^.left, fpar); fpar := fpar^.link END
  1362.         ELSIF (x^.class # Ntype) & (x^.typ # NIL) & (x^.typ^.form = ProcTyp) THEN
  1363.             fpar := x^.typ^.link
  1364.         ELSE err(121); fpar := NIL; x^.typ := OPT.undftyp
  1365.         END
  1366.     END PrepCall;
  1367.     PROCEDURE Param*(ap: OPT.Node; fp: OPT.Object);
  1368.         VAR q: OPT.Struct;
  1369.     BEGIN
  1370.         IF fp.typ.form # Undef THEN
  1371.             IF fp^.mode = VarPar THEN
  1372.                 IF NotVar(ap) THEN err(122)
  1373.                 ELSE CheckLeaf(ap, FALSE)
  1374.                 END ;
  1375.                 IF ap^.readonly THEN err(76) END ;
  1376.                 IF fp^.typ^.comp = DynArr THEN DynArrParCheck(fp^.typ, ap^.typ, TRUE)
  1377.                 ELSIF (fp^.typ^.comp = Record) & (ap^.typ^.comp = Record) THEN
  1378.                     q := ap^.typ;
  1379.                     WHILE (q # fp^.typ) & (q # NIL) & (q # OPT.undftyp) DO q := q^.BaseTyp END ;
  1380.                     IF q = NIL THEN err(111) END
  1381.                 ELSIF (fp^.typ = OPT.sysptrtyp) & (ap^.typ^.form = Pointer) THEN (* ok *)
  1382.                 ELSIF (ap^.typ # fp^.typ) & ~((fp^.typ^.form = Byte) & (ap^.typ^.form IN {Char, SInt})) THEN err(123)
  1383.                 END
  1384.             ELSIF fp^.typ^.comp = DynArr THEN
  1385.                 IF (ap^.class = Nconst) & (ap^.typ^.form = Char) THEN CharToString(ap) END ;
  1386.                 IF (ap^.typ^.form = String) & (fp^.typ^.BaseTyp^.form = Char) THEN (* ok *)
  1387.                 ELSIF ap^.class >= Nconst THEN err(59)
  1388.                 ELSE DynArrParCheck(fp^.typ, ap^.typ, FALSE)
  1389.                 END
  1390.             ELSE CheckAssign(fp^.typ, ap)
  1391.             END
  1392.         END
  1393.     END Param;
  1394.     PROCEDURE StaticLink*(dlev: SHORTINT);
  1395.         VAR scope: OPT.Object;
  1396.     BEGIN
  1397.         scope := OPT.topScope;
  1398.         WHILE dlev > 0 DO DEC(dlev);
  1399.             INCL(scope^.link^.conval^.setval, slNeeded);
  1400.             scope := scope^.left
  1401.         END
  1402.     END StaticLink;
  1403.     PROCEDURE Call*(VAR x: OPT.Node; apar: OPT.Node; fp: OPT.Object);
  1404.         VAR typ: OPT.Struct; p: OPT.Node; lev: SHORTINT;
  1405.     BEGIN
  1406.         IF x^.class = Nproc THEN typ := x^.typ;
  1407.             lev := x^.obj^.mnolev;
  1408.             IF lev > 0 THEN StaticLink(OPT.topScope^.mnolev-lev) END ;
  1409.             IF x^.obj^.mode = IProc THEN err(121) END
  1410.         ELSIF (x^.class = Nfield) & (x^.obj^.mode = TProc) THEN typ := x^.typ;
  1411.             x^.class := Nproc; p := x^.left; x^.left := NIL; p^.link := apar; apar := p; fp := x^.obj^.link
  1412.         ELSE typ := x^.typ^.BaseTyp
  1413.         END ;
  1414.         BindNodes(Ncall, typ, x, apar); x^.obj := fp
  1415.     END Call;
  1416.     PROCEDURE Enter*(VAR procdec: OPT.Node; stat: OPT.Node; proc: OPT.Object);
  1417.         VAR x: OPT.Node;
  1418.     BEGIN
  1419.         x := OPT.NewNode(Nenter); x^.typ := OPT.notyp; x^.obj := proc;
  1420.         x^.left := procdec; x^.right := stat; procdec := x
  1421.     END Enter;
  1422.     PROCEDURE Return*(VAR x: OPT.Node; proc: OPT.Object);
  1423.         VAR node: OPT.Node;
  1424.     BEGIN
  1425.         IF proc = NIL THEN (* return from module *)
  1426.             IF x # NIL THEN err(124) END
  1427.         ELSE
  1428.             IF x # NIL THEN CheckAssign(proc^.typ, x)
  1429.             ELSIF proc^.typ # OPT.notyp THEN err(124)
  1430.             END
  1431.         END ;
  1432.         node := OPT.NewNode(Nreturn); node^.typ := OPT.notyp; node^.obj := proc; node^.left := x; x := node
  1433.     END Return;
  1434.     PROCEDURE Assign*(VAR x: OPT.Node; y: OPT.Node);
  1435.         VAR z: OPT.Node;
  1436.     BEGIN
  1437.         IF x^.class >= Nconst THEN err(56) END ;
  1438.         CheckAssign(x^.typ, y);
  1439.         IF x^.readonly THEN err(76) END ;
  1440.         IF x^.typ^.comp = Record THEN
  1441.             IF x^.class = Nguard THEN z := x^.left ELSE z := x END ;
  1442.             IF (z^.class = Nderef) & (z^.left^.class = Nguard) THEN
  1443.                 z^.left := z^.left^.left    (* skip guard before dereferencing *)
  1444.             END ;
  1445.             IF (x^.typ^.strobj # NIL) & ((z^.class = Nderef) OR (z^.class = Nvarpar)) THEN
  1446.                 BindNodes(Neguard, x^.typ, z, NIL); x := z
  1447.             END
  1448.         ELSIF (x^.typ^.comp = Array) & (x^.typ^.BaseTyp = OPT.chartyp) &
  1449.                 (y^.typ^.form = String) & (y^.conval^.intval2 = 1) THEN    (* replace array := "" with array[0] := 0X *)
  1450.             y^.typ := OPT.chartyp; y^.conval^.intval := 0;
  1451.             Index(x, NewIntConst(0))
  1452.         END ;
  1453.         BindNodes(Nassign, OPT.notyp, x, y); x^.subcl := assign
  1454.     END Assign;
  1455.     PROCEDURE Inittd*(VAR inittd, last: OPT.Node; typ: OPT.Struct);
  1456.         VAR node: OPT.Node;
  1457.     BEGIN
  1458.         node := OPT.NewNode(Ninittd); node^.typ := typ;
  1459.         node^.conval := OPT.NewConst(); node^.conval^.intval := typ^.txtpos;
  1460.         IF inittd = NIL THEN inittd := node ELSE last^.link := node END ;
  1461.         last := node
  1462.     END Inittd;
  1463. BEGIN
  1464.     maxExp := log(MAX(LONGINT) DIV 2 + 1); maxExp := exp
  1465. END POPB.
  1466.